The Developer Connection - Device Driver Kit for OS/2 3

home *** CD-ROM | disk | FTP | other *** search

/ The Developer Connection…ice Driver Kit for OS/2 3 / DEV3-D1.ISO / devtools / dataflex / dfhelp_c.src < prev next >

Wrap

Text File | 1993-05-19 | 69.5 KB | 1,907 lines

// dfhelp_c.src (secondary help maintenance program [C]) // July 17, 1991 // LS use dfhelp_c // secondary help maintenance program [C] header package ////////////////////////////////// ////////////////////////////////// global variables ////////////////////////////////// string cmd_option // option passed on cmd line (via chain wait) move EMPTY_STRING to cmd_option string current_grp current_sbj current_xrf current_ctx current_pth move EMPTY_STRING to current_grp // names of currently open help data files move EMPTY_STRING to current_sbj // passed on cmd line (via chain wait) move EMPTY_STRING to current_xrf move EMPTY_STRING to current_ctx move EMPTY_STRING to current_pth ////////////////////////////////// ////////////////////////////////// global procedures ////////////////////////////////// procedure deactivate_area for desktop send deactivate AREA_TYPE end_procedure procedure insert_cb for desktop string val integer itm local integer flag get insert_mode of clipboard to flag set insert_mode of clipboard to true send goto_line to clipboard itm set right_margin of clipboard to 56 send key to clipboard kenter set value of clipboard item itm to val set insert_mode of clipboard to flag end_procedure function next_cmd_arg for desktop returns string local string arg cmdline arg if arg le EMPTY_STRING begin error 57 ("Command line argument not specified") send insert_cb FAIL_REPLY 0 abort end if arg eq EMPTY_REPL_STRING function_return EMPTY_STRING else function_return arg end_function // retrieve option passed on command line to determine which objects to use procedure init_program for desktop // retrieve option passed on command line to determine which objects to use cmdline cmd_option if cmd_option le EMPTY_STRING begin error 57 ("Option not specified for program.") send insert_cb FAIL_REPLY 0 abort end left cmd_option to cmd_option 1 uppercase cmd_option if not cmd_option in VALID_OPTIONS begin error 57 ("Invalid option passed to program: " + cmd_option) send insert_cb FAIL_REPLY 0 abort end get next_cmd_arg to current_grp get next_cmd_arg to current_sbj get next_cmd_arg to current_xrf get next_cmd_arg to current_ctx get next_cmd_arg to current_pth end_procedure procedure exit_program for desktop send insert_cb ABORT_REPLY 0 send exit_application end_procedure send init_program ////////////////////////////////// ////////////////////////////////// augmentation to help_object class to ////////////////////////////////// override default help access ////////////////////////////////// procedure request_help for (class(help_object.obj)) integer msg_id integer arg local integer orig_grp orig_sbj orig_xrf orig_ctx local string old_grp_filename old_sbj_filename old_xrf_filename old_ctx_filename local string cur_grp_filename cur_sbj_filename cur_xrf_filename cur_ctx_filename move current_pth to cur_grp_filename append cur_grp_filename current_grp move current_pth to cur_sbj_filename append cur_sbj_filename current_sbj move current_pth to cur_xrf_filename append cur_xrf_filename current_xrf move current_pth to cur_ctx_filename append cur_ctx_filename current_ctx if cur_grp_filename gt EMPTY_STRING begin move grp.recnum to orig_grp close grp end if cur_sbj_filename gt EMPTY_STRING begin move sbj.recnum to orig_sbj close sbj end if cur_xrf_filename gt EMPTY_STRING begin move xrf.recnum to orig_xrf close xrf end if cur_ctx_filename gt EMPTY_STRING begin move ctx.recnum to orig_ctx close ctx end if num_arguments gt 1 send msg_id arg else send msg_id if cur_grp_filename gt EMPTY_STRING begin open cur_grp_filename as grp clear grp if orig_grp ne 0 begin move orig_grp to grp.recnum find eq grp.recnum end end if cur_sbj_filename gt EMPTY_STRING begin open cur_sbj_filename as sbj clear sbj if orig_sbj ne 0 begin move orig_sbj to sbj.recnum find eq sbj.recnum end end if cur_xrf_filename gt EMPTY_STRING begin open cur_xrf_filename as xrf clear xrf if orig_xrf ne 0 begin move orig_xrf to xrf.recnum find eq xrf.recnum end end if cur_ctx_filename gt EMPTY_STRING begin open cur_ctx_filename as ctx clear ctx if orig_ctx ne 0 begin move orig_ctx to ctx.recnum find eq ctx.recnum end end end_procedure ////////////////////////////////// ////////////////////////////////// classes ////////////////////////////////// // class for displaying information in a text window class display_window is an edit register_function initial_highlight_color returns integer procedure construct_object forward send construct_object property integer highlight_color public (initial_highlight_color(current_object)) property integer normal_colors public (object_color(current_object)) end_procedure function initial_highlight_color returns integer local integer obj chk_obj pal ret_val move current_object to obj repeat move obj to chk_obj get class_palette (class(chk_obj)) to pal if pal eq 0 get parent of chk_obj to obj until (pal <> 0 or chk_obj = desktop) get palette_color pal POINTED_CURSOR_TYPE to ret_val function_return ret_val end_function procedure entering returns integer local integer ret_val forward get msg_entering to ret_val if not ret_val set object_color to ; (highlight_color(current_object)) (low(normal_colors(current_object))) end_procedure procedure exiting integer obj returns integer local integer ret_val clrs forward get msg_exiting obj to ret_val if not ret_val begin get normal_colors to clrs set object_color to (hi(clrs)) (low(clrs)) end end_procedure procedure release_focus local integer ret_val clrs forward send release_focus get normal_colors to clrs set object_color to (hi(clrs)) (low(clrs)) end_procedure set class_colors to u_!$ 0 0 // set colors for current class to inherit end_class ////////////////////////////////// ////////////////////////////////// main object definitions ////////////////////////////////// if cmd_option eq CTX_MAINT_OPTION begin /trans_data_img ╔════════════════════════════════════════════════════════════════╗ ║________________________________________________________________║ ║ ║ ║ ┌─ Operation: ──────────┐ ║ ║ │ _____________ │ ║ ║ │ _____________ │ ║ ║ └───────────────────────┘ ║ ║ ┌─ Original context values: ─────────────────────────────────┐ ║ ║ │ Application name: _______________ │ ║ ║ │ Module name: _______________ │ ║ ║ │ Help name: ________________________________________ │ ║ ║ └────────────────────────────────────────────────────────────┘ ║ ║ ┌─ New context values: ──────────────────────────────────────┐ ║ ║ │ Application name: _______________ │ ║ ║ │ Module name: _______________ │ ║ ║ │ Help name: ________________________________________ │ ║ ║ └────────────────────────────────────────────────────────────┘ ║ ║ __________ _____________________ ║ ║ __________ ___________ _________ ║ ╚════════════════════════════════════════════════════════════════╝ /* // ( ) Delete // ( ) Translate // // <F2=Begin> <Alt+F2=Display only> // <F5=Clear> <Esc=Close> <F1=Help> sub_page trans_data_oper_img from trans_data_img 2 3 sub_page trans_data_old_img from trans_data_img 4 5 6 sub_page trans_data_new_img from trans_data_img 7 8 9 sub_page trans_data_btns_img from trans_data_img 10 11 12 13 14 object trans_data is a client trans_data_img set location to 2 7 relative set popup_state to true set scope_state to true set center_state item 0 to true set value item 0 to "Context Maintenance" object operation is a checkbox trans_data_oper_img set select_mode to auto_select item_list on_item "Delete" send next set select_state to true on_item "Translate" send next end_item_list on_key kcancel send request_cancel private on_key kclear send request_clear private on_key key_alt+key_f2 send display_only private on_key ksave_record send request_begin private procedure select_toggling integer itm integer flag forward send select_toggling itm flag delegate send reset_mode end_procedure function translate_state returns integer function_return (select_state(current_object,1)) end_function end_object // operation object old_data is a form trans_data_old_img item_list on_item EMPTY_STRING send next on_item EMPTY_STRING send next on_item EMPTY_STRING send next end_item_list on_key kenter send next private on_key kcancel send request_cancel private on_key key_alt+key_f2 send display_only private on_key kclear send request_clear private on_key ksave_record send request_begin private end_object object new_data is a form trans_data_new_img item_list on_item EMPTY_STRING send next on_item EMPTY_STRING send next on_item EMPTY_STRING send next end_item_list on_key kenter send next private on_key kcancel send request_cancel private on_key key_alt+key_f2 send display_only private on_key kclear send request_clear private on_key ksave_record send request_begin private end_object // new_data object buttons is a button trans_data_btns_img item_list on_item "<F2=Begin>" send request_begin on_item "<Alt+F2=Display only>" send display_only on_item "<F5=Clear>" send request_clear on_item ESC_CLOSE_TEXT send request_cancel on_item F1_HELP_TEXT send help end_item_list on_key kcancel send request_cancel private on_key key_alt+key_f2 send display_only private on_key kclear send request_clear private on_key ksave_record send request_begin private end_object /trans_process_img ╔════════════════════════════════════════════╗ ║ ║ ║ ║ ║ ║ ║ ║ ║ ║ ╚════════════════════════════════════════════╝ /trans_process_display_img _________ ______ ____________ ______ /trans_process_cancel_btn_img ____________ /* object process is a client trans_process_img set popup_state to true set location to 5 10 relative object display is a message trans_process_display_img set focus_mode to nonfocusable set location to 2 4 relative end_object object button is a button trans_process_cancel_btn_img set location to 4 17 relative item_list on_item ESC_CANCEL_TEXT send none end_item_list /trans_interrupt_img ╔═══════════════════════════════════════════════════════╗ ║ Translation/deletion interrupted. ║ ║ ║ ║ _____________ ___________ ║ ╚═══════════════════════════════════════════════════════╝ /* object interrupt is a button trans_interrupt_img set block_mouse_state to true set location to 0 -23 relative set popup_state to true set scope_state to true item_list on_item "<F2=Continue>" send ok on_item "<Esc=Abort>" send cancel end_item_list on_key ksave_record send ok on_key kcancel send cancel end_object function check_interrupt returns integer local string trash local integer wloc mloc ret_val inkey trash if (termchar eq kexit_application or ; termchar eq kcancel or ; termchar eq kmouse) begin if (termchar eq kmouse) begin get window_location item 1 to wloc move (wloc + location(current_object)) to wloc get absolute_mouse_location to mloc if not (mloc >= wloc and mloc < (wloc + length(value(current_object,0)))) ; function_return 0 end set kbd_input_mode to 1 set highlight_state to false ui_accept (interrupt(current_object)) to ret_val if ret_val ne msg_ok function_return 1 set highlight_state to true set kbd_input_mode to 2 end function_return 0 end_function end_object // button procedure init_display integer flag local integer obj move (display(current_object)) to obj send delete_data to obj set value of obj item 0 to "Scanning:" if flag set value of obj item 2 to "Translating:" else set value of obj item 2 to " Deleting:" end_procedure function scan integer itm returns integer local integer ret_val obj move (display(current_object)) to obj set value of obj item ((itm * 2) + 1) to (value(obj,(itm * 2) + 1) + 1) get check_interrupt of (button(current_object)) to ret_val function_return ret_val end_function end_object // process /trans_display_list_img ╔═══════════════════════════════════════════╗ ║___________________________________________║ ║ ║ ║ ║ ║ ║ ║ ║ ║ ║ ║ ║ ║ ║ ║ ║ ║ ║ ║ ║ ╚═══════════════════════════════════════════╝ /trans_display_list_btn_img _______ _________ /* // <F2=OK> <F1=Help> object display_list is a client trans_display_list_img set block_mouse_state to true set location to 0 10 relative set popup_state to true set scope_state to true set center_state item 0 to true set value item 0 to "Contexts to be deleted/translated" object button is a button trans_display_list_btn_img set location to 11 1 relative item_list on_item F2_OK_TEXT send request_ok on_item F1_HELP_TEXT send help end_item_list on_key ksave_record send request_ok private end_object // button before list places focus on button during default activate of client object list is a display_window set size to 8 42 set location to 3 1 relative set object_color to (hi(object_color(parent(current_object)))) (low(object_color(parent(current_object)))) set read_only_state to true on_key ksave_record send request_ok private procedure insert_line string txt local string newline set read_only_state to false send insert txt send process_key kenter set read_only_state to true end_procedure end_object procedure request_ok send deactivate_area send delete_data delegate send restart end_procedure procedure delete_data send delete_data to (list(current_object)) end_procedure procedure release_focus forward send release_focus send delete_data end_procedure procedure show_trans_ctx integer flag string app_name string mod_name string hlp_name local integer obj move (list(current_object)) to obj if flag send insert_line to obj "NEW:" else send insert_line to obj "ORIGINAL:" send insert_line to obj (trim(app_name)) send insert_line to obj (trim(mod_name)) send insert_line to obj (trim(hlp_name)) end_procedure procedure show_del_ctx string app_name string mod_name string hlp_name local integer obj move (list(current_object)) to obj send insert_line to obj "DELETE:" send insert_line to obj (trim(app_name)) send insert_line to obj (trim(mod_name)) send insert_line to obj (trim(hlp_name)) end_procedure end_object // display_list /trans_done_img ╔═══════════════════════════════════════════════════════╗ ║ Translation/deletion complete. ║ ║ ║ ║ ____ ______ ║ ╚═══════════════════════════════════════════════════════╝ /* object done is a button trans_done_img set block_mouse_state to true set location to 9 4 relative set popup_state to true set scope_state to true item_list on_item "<OK>" send request_ok on_item "<Help>" send help end_item_list procedure request_ok send deactivate_area delegate send restart end_procedure end_object function translate_state returns integer function_return (translate_state(operation(current_object))) end_function procedure reset_mode local integer flag tot_itms itm obj get translate_state to flag move (not(flag)) to flag move (new_data(current_object)) to obj move (item_count(obj) - 1) to tot_itms for itm from 0 to tot_itms set shadow_state of obj item itm to flag loop end_procedure function mask integer which_mask returns string local integer obj itm if which_mask lt NEW_APP_TYPE begin move (old_data(current_object)) to obj move which_mask to itm end else begin move (new_data(current_object)) to obj move (which_mask - NEW_APP_TYPE) to itm end function_return (value(obj,itm)) end_function procedure set mask integer which_mask string new_val local integer obj itm if which_mask lt NEW_APP_TYPE begin move (old_data(current_object)) to obj move which_mask to itm end else begin move (new_data(current_object)) to obj move (which_mask - NEW_APP_TYPE) to itm end set value of obj item itm to new_val end_procedure function trim_star string old_val returns string local integer cpos pos "*" in old_val to cpos if cpos ne 0 function_return (left(old_val,cpos)) function_return old_val end_function procedure trim_masks local integer cpos local string test_val set mask OLD_APP_TYPE to (trim_star(current_object,mask(current_object,OLD_APP_TYPE))) set mask OLD_MOD_TYPE to (trim_star(current_object,mask(current_object,OLD_MOD_TYPE))) set mask OLD_HLP_TYPE to (trim_star(current_object,mask(current_object,OLD_HLP_TYPE))) set mask NEW_APP_TYPE to (trim_star(current_object,mask(current_object,NEW_APP_TYPE))) set mask NEW_MOD_TYPE to (trim_star(current_object,mask(current_object,NEW_MOD_TYPE))) set mask NEW_HLP_TYPE to (trim_star(current_object,mask(current_object,NEW_HLP_TYPE))) end_procedure function wild_chars string wild_val returns integer local integer cpos wcount move 0 to wcount pos "?" in wild_val to cpos while cpos ne 0 replace "?" in wild_val with EMPTY_REPL_STRING increment wcount pos "?" in wild_val to cpos end pos "*" in wild_val to cpos if cpos ne 0 move (0 - wcount) to wcount // negative means "*" char function_return wcount end_function function compare_wild_count integer old_wc integer new_wc returns integer if (abs(old_wc) < abs(new_wc) or ; // must have fewer ? in old than in new (old_wc >= 0 and new_wc < 0)) function_return 1 // if * not in old, new cannot have * end_function function validate_masks returns integer local integer old_wild_count new_wild_count get wild_chars (mask(current_object,OLD_APP_TYPE)) to old_wild_count get wild_chars (mask(current_object,NEW_APP_TYPE)) to new_wild_count if (compare_wild_count(current_object, old_wild_count, new_wild_count)) function_return 1 get wild_chars (mask(current_object,OLD_MOD_TYPE)) to old_wild_count get wild_chars (mask(current_object,NEW_MOD_TYPE)) to new_wild_count if (compare_wild_count(current_object, old_wild_count, new_wild_count)) function_return 2 get wild_chars (mask(current_object,OLD_HLP_TYPE)) to old_wild_count get wild_chars (mask(current_object,NEW_HLP_TYPE)) to new_wild_count if (compare_wild_count(current_object, old_wild_count, new_wild_count)) function_return 3 end_function function translated_value string old_val string pold_mask string new_mask returns string local string new_val old_mask local integer old_cpos new_cpos move pold_mask to old_mask move new_mask to new_val pos "?" in old_mask to old_cpos while old_cpos ne 0 replace "?" in new_val with (mid(old_val,1,old_cpos)) replace "?" in old_mask with EMPTY_REPL_STRING pos "?" in old_mask to old_cpos end pos "*" in old_mask to old_cpos if old_cpos ne 0 begin pos "*" in new_val to new_cpos if new_cpos ne 0 begin left new_val to new_val (new_cpos - 1) append new_val (right(old_val,length(old_val) - old_cpos + 1)) end end function_return new_val end_function procedure restart set kbd_input_mode to 1 send deactivate to (process(current_object)) send deactivate to (display_list(current_object)) end_procedure procedure request_clear set current_item of (operation(current_object)) to 0 send delete_data to (new_data(current_object)) send delete_data to (old_data(current_object)) send activate to (operation(current_object)) end_procedure procedure init_process integer live local integer obj send init_display to (process(current_object)) (translate_state(current_object)) if not live begin set max_lines of (list(display_list(current_object))) to MAX_LINES_ALLOWED send delete_data to (display_list(current_object)) send popup to (display_list(current_object)) end move (process(current_object)) to obj send delete_data to obj send popup to obj set highlight_state of (button(obj)) to true set kbd_input_mode to 2 end_procedure procedure process_complete integer live set kbd_input_mode to 1 set highlight_state of (button(process(current_object))) to false if live send popup to (done(current_object)) else begin set max_lines of (list(display_list(current_object))) to (line_count(list(display_list(current_object))) + 1) send deactivate to (process(current_object)) end end_procedure procedure request_begin send request_operation true end_procedure procedure display_only send request_operation false end_procedure procedure request_operation integer live local integer obj ret_val app_typ mod_typ hlp_typ trans_state local string app_test mod_test hlp_test get translate_state to trans_state if not trans_state send delete_data to (new_data(current_object)) send trim_masks uppercase (mask(current_object,OLD_APP_TYPE)) to app_test uppercase (mask(current_object,OLD_MOD_TYPE)) to mod_test uppercase (mask(current_object,OLD_HLP_TYPE)) to hlp_test if app_test gt EMPTY_STRING move 1 to app_typ if mod_test gt EMPTY_STRING move 1 to mod_typ if hlp_test gt EMPTY_STRING move 1 to hlp_typ if trans_state begin if (validate_masks(current_object)) begin send activate to (old_data(current_object)) set current_item of (old_data(current_object)) to (ret_val - 1) error 15 "Translation formats do not match" procedure_return end move (app_typ or mask(current_object,NEW_APP_TYPE) > EMPTY_STRING) to app_typ move (mod_typ or mask(current_object,NEW_MOD_TYPE) > EMPTY_STRING) to mod_typ move (hlp_typ or mask(current_object,NEW_HLP_TYPE) > EMPTY_STRING) to ret_val end if not (app_typ or mod_typ or hlp_typ) begin send activate to (old_data(current_object)) set current_item of (old_data(current_object)) to 0 error 13 "Criteria for Contexts must be specified" procedure_return end send init_process live clear ctx find ge ctx.recnum [found] repeat if (scan(current_object,CTX_MAINT_SCAN_TYPE)) begin send restart procedure_return end if app_typ indicate found as ; app_test match (uppercase(trim(ctx.app_name))) [found] if mod_typ indicate found as ; mod_test match (uppercase(trim(ctx.mod_name))) [found] if hlp_typ indicate found as ; hlp_test match (uppercase(trim(ctx.hlp_name))) [found] begin indicate err false if live get act_on_record trans_state app_typ mod_typ hlp_typ to ret_val else get show_operation trans_state app_typ mod_typ hlp_typ to ret_val // match! [err] procedure_return // abort on error if ret_val begin send restart procedure_return end end find gt ctx.recnum [found] loop send process_complete live end_procedure function scan integer itm returns integer function_return (scan(process(current_object),itm)) end_function function translated_app_name returns string function_return (translated_value(current_object,ctx.app_name, ; (mask(current_object,OLD_APP_TYPE)), ; (mask(current_object,NEW_APP_TYPE)))) end_function function translated_mod_name returns string function_return (translated_value(current_object,ctx.mod_name, ; (mask(current_object,OLD_MOD_TYPE)), ; (mask(current_object,NEW_MOD_TYPE)))) end_function function translated_hlp_name returns string function_return (translated_value(current_object,ctx.hlp_name, ; (mask(current_object,OLD_HLP_TYPE)), ; (mask(current_object,NEW_HLP_TYPE)))) end_function function show_operation integer trans_state integer app_typ integer mod_typ integer hlp_typ returns integer local integer ret_val obj old_rec show_oper_state local string app_val mod_val hlp_val move 1 to show_oper_state move (display_list(current_object)) to obj if trans_state begin move ctx.recnum to old_rec if app_typ get translated_app_name to app_val else move ctx.app_name to app_val if mod_typ get translated_mod_name to mod_val else move ctx.mod_name to mod_val if hlp_typ get translated_hlp_name to hlp_val else move ctx.hlp_name to hlp_val clear ctx move app_val to ctx.app_name move mod_val to ctx.mod_name move hlp_val to ctx.hlp_name find eq ctx.hlp_name [found] move 0 to show_oper_state clear ctx move old_rec to ctx.recnum find eq ctx.recnum if show_oper_state begin send show_trans_ctx to obj false ctx.app_name ctx.mod_name ctx.hlp_name send show_trans_ctx to obj true app_val mod_val hlp_val end end else send show_del_ctx to obj ctx.app_name ctx.mod_name ctx.hlp_name if show_oper_state function_return (scan(current_object,CTX_MAINT_OPER_TYPE)) end_function function act_on_record integer trans_state integer app_typ integer mod_typ integer hlp_typ returns integer local integer old_rec show_oper_state local string app_val mod_val hlp_val move ctx.recnum to old_rec move 1 to show_oper_state indicate err false REREAD ctx [not err] begin if trans_state begin if app_typ get translated_app_name to app_val else move ctx.app_name to app_val if mod_typ get translated_mod_name to mod_val else move ctx.mod_name to mod_val if hlp_typ get translated_hlp_name to hlp_val else move ctx.hlp_name to hlp_val clear ctx move app_val to ctx.app_name move mod_val to ctx.mod_name move hlp_val to ctx.hlp_name find eq ctx.hlp_name [found] move 0 to show_oper_state clear ctx move old_rec to ctx.recnum find eq ctx.recnum if show_oper_state begin move app_val to ctx.app_name move mod_val to ctx.mod_name move hlp_val to ctx.hlp_name saverecord ctx end end else begin delete ctx move old_rec to ctx.recnum end end UNLOCK [not err] if show_oper_state if (scan(current_object,CTX_MAINT_OPER_TYPE)) function_return 1 function_return 0 end_function procedure request_cancel send deactivate_area send insert_cb SUCCESS_REPLY 0 end_procedure procedure activating send reset_mode end_procedure end_object // trans_data send popup to trans_data end else if cmd_option eq CLN_MAINT_OPTION begin /cleanup_img ╔══════════════════════════════════════════════════════════════╗ ║______________________________________________________________║ ║ ║ ║ Delete: ║ ║ ________________________________________ ║ ║ ________________________________________ ║ ║ ________________________________________ ║ ║ ________________________________________ ║ ║ ║ ║ ________________________________________ ║ ║ ║ ║ __________ _____________________ ___________ _________ ║ ╚══════════════════════════════════════════════════════════════╝ /* // <F2=Begin> <Alt+F2=Display only> <Esc=Close> <F1=Help> sub_page cleanup_options_img from cleanup_img 2 3 4 5 6 sub_page cleanup_buttons_img from cleanup_img 7 8 9 10 object cleanup is a client cleanup_img set block_mouse_state to true set location to 4 8 relative set popup_state to true set scope_state to true set center_state item 0 to true set value item 0 to "Cleanup" object options is a checkbox cleanup_options_img set select_mode to multi_select item_list on_item "Links for invalid Groups or Subjects" send next on_item "Contexts for invalid Links" send next on_item "Groups without Links" send next on_item "Subjects without Links" send next on_item "Write to .DEL file" send next end_item_list on_key key_alt+key_f2 send display_only private on_key ksave_record send request_begin private on_key kcancel send request_cancel private end_object object buttons is a button cleanup_buttons_img item_list on_item "<F2=Begin>" send request_begin on_item "<Alt+F2=Display only>" send display_only on_item ESC_CLOSE_TEXT send request_cancel on_item F1_HELP_TEXT send help end_item_list on_key key_alt+key_f2 send display_only private on_key ksave_record send request_begin private on_key kcancel send request_cancel private end_object /cleanup_process_img ╔═══════════════════════════════════════════════════════════════╗ ║ ║ ║ Scanning ________ Validated: _____. Deleted: _____. ║ ║ ║ ║ ║ ║ ║ ╚═══════════════════════════════════════════════════════════════╝ /cleanup_process_cancel_btn_img ____________ /* object process is a client cleanup_process_img set popup_state to true set location to 2 -1 relative object button is a button cleanup_process_cancel_btn_img set location to 4 26 relative item_list on_item ESC_CANCEL_TEXT send none end_item_list /cleanup_interrupt_img ╔═══════════════════════════════════════════════════════╗ ║ Cleanup interrupted. ║ ║ ║ ║ _____________ ___________ ║ ╚═══════════════════════════════════════════════════════╝ /* object interrupt is a button cleanup_interrupt_img set block_mouse_state to true set location to 0 -23 relative set popup_state to true set scope_state to true item_list on_item "<F2=Continue>" send ok on_item "<Esc=Abort>" send cancel end_item_list on_key ksave_record send ok on_key kcancel send cancel end_object function check_interrupt returns integer local string trash local integer wloc mloc ret_val inkey trash if (termchar eq kexit_application or ; termchar eq kcancel or ; termchar eq kmouse) begin if (termchar eq kmouse) begin get window_location item 1 to wloc move (wloc + location(current_object)) to wloc get absolute_mouse_location to mloc if not (mloc >= wloc and mloc < (wloc + length(value(current_object,0)))) ; function_return 0 end set kbd_input_mode to 1 set highlight_state to false ui_accept (interrupt(current_object)) to ret_val if ret_val ne msg_ok function_return 1 set highlight_state to true set kbd_input_mode to 2 end function_return 0 end_function end_object procedure start_process string rec_name set value item 0 to rec_name set value item 1 to 0 set value item 2 to 0 end_procedure function scan integer itm returns integer local integer ret_val obj set value item (itm + 1) to (value(current_object,itm + 1) + 1) get check_interrupt of (button(current_object)) to ret_val function_return ret_val end_function end_object /cleanup_display_list_img ╔═══════════════════════════════════════════╗ ║___________________________________________║ ║ ║ ║ ║ ║ ║ ║ ║ ║ ║ ║ ║ ║ ║ ║ ║ ║ ║ ║ ║ ╚═══════════════════════════════════════════╝ /cleanup_display_list_btn_img _______ _________ /* // <F2=OK> <F1=Help> object display_list is a client cleanup_display_list_img set block_mouse_state to true set location to 0 8 relative set popup_state to true set scope_state to true set center_state item 0 to true set value item 0 to "Records to be deleted" object button is a button cleanup_display_list_btn_img set location to 11 1 relative item_list on_item F2_OK_TEXT send request_ok on_item F1_HELP_TEXT send help end_item_list on_key ksave_record send request_ok private end_object // button before list places focus on button during default activate of client object list is a display_window set size to 8 42 set location to 3 1 relative set read_only_state to true on_key ksave_record send request_ok private procedure insert_line string txt local string newline set read_only_state to false send insert txt send process_key kenter set read_only_state to true end_procedure end_object procedure request_ok send deactivate_area send delete_data delegate send restart end_procedure procedure delete_data send delete_data to (list(current_object)) end_procedure procedure release_focus forward send release_focus send delete_data end_procedure procedure show_del_grp string grp_name local integer obj move (list(current_object)) to obj send insert_line to obj "DELETE GROUP:" send insert_line to obj (trim(grp_name)) end_procedure procedure show_del_sbj string sbj_name local integer obj move (list(current_object)) to obj send insert_line to obj "DELETE SUBJECT:" send insert_line to obj (trim(sbj_name)) end_procedure procedure show_del_xrf string grp_name string sbj_name local integer obj move (list(current_object)) to obj send insert_line to obj "DELETE LINK FOR:" send insert_line to obj (trim(grp_name)) send insert_line to obj (trim(sbj_name)) end_procedure procedure show_del_ctx string app_name string mod_name string hlp_name local integer obj move (list(current_object)) to obj send insert_line to obj "DELETE CONTEXT:" send insert_line to obj (trim(app_name)) send insert_line to obj (trim(mod_name)) send insert_line to obj (trim(hlp_name)) end_procedure end_object // display_list /cleanup_done_img ╔═══════════════════════════════════════════════════════╗ ║ Cleanup complete. ║ ║ ║ ║ ____ ______ ║ ╚═══════════════════════════════════════════════════════╝ /* object done is a button cleanup_done_img set block_mouse_state to true set location to 6 2 relative set popup_state to true set scope_state to true item_list on_item "<OK>" send request_cancel on_item "<Help>" send help end_item_list end_object object sbj_text is an edit set focus_mode to no_activate set size to 1 56 end_object procedure activating local integer obj move (options(current_object)) to obj set select_state of obj item 0 to true set select_state of obj item 1 to true set select_state of obj item 2 to false set select_state of obj item 3 to false forward send activating end_procedure procedure restart set kbd_input_mode to 1 send deactivate to (process(current_object)) send deactivate to (display_list(current_object)) end_procedure procedure init_process integer live local integer obj if not live begin set max_lines of (list(display_list(current_object))) to MAX_LINES_ALLOWED send delete_data to (display_list(current_object)) send popup to (display_list(current_object)) end move (process(current_object)) to obj send delete_data to obj send popup to obj set highlight_state of (button(obj)) to true set kbd_input_mode to 2 end_procedure procedure process_complete integer live set kbd_input_mode to 1 set highlight_state of (button(process(current_object))) to false if live send popup to (done(current_object)) else begin set max_lines of (list(display_list(current_object))) to (line_count(list(display_list(current_object))) + 1) send deactivate to (process(current_object)) end end_procedure procedure request_begin send request_cleanup true end_procedure procedure display_only send request_cleanup false end_procedure procedure request_cleanup integer live local integer rec opt disp wr_del move (options(current_object)) to opt move (display_list(current_object)) to disp send init_process live get select_state of opt item 4 to wr_del if (select_state(opt, 0)) begin send start_process to (process(current_object)) "Links" if (live and wr_del) direct_output (current_pth + current_xrf + DEL_EXT_TEXT) clear xrf find ge xrf by recnum [found] repeat if (scan(current_object,CLN_SCAN_TYPE)) begin if (live and wr_del) close_output send restart procedure_return end clear grp move xrf.grp_recnum to grp.recnum find eq grp by recnum [found] begin clear sbj move xrf.sbj_recnum to sbj.recnum find eq sbj by recnum end [not found] begin if live begin if wr_del send write_del_xrf move xrf.recnum to rec indicate err false reread xrf [not err] delete xrf unlock clear xrf move rec to xrf.recnum end else send show_del_xrf to disp xrf.grp_recnum xrf.sbj_recnum if (scan(current_object,CLN_DEL_TYPE)) begin if (live and wr_del) close_output send restart procedure_return end end find gt xrf by recnum [found] loop end if (select_state(opt, 1)) begin send start_process to (process(current_object)) "Contexts" if (live and wr_del) direct_output (current_pth + current_ctx + DEL_EXT_TEXT) clear ctx find ge ctx by recnum [found] repeat if (scan(current_object,CLN_SCAN_TYPE)) begin if (live and wr_del) close_output send restart procedure_return end clear xrf move ctx.xrf_recnum to xrf.recnum find eq xrf by recnum [not found] begin if live begin if wr_del send write_del_ctx move ctx.recnum to rec indicate err false reread ctx [not err] delete ctx unlock clear ctx move rec to ctx.recnum end else send show_del_ctx to disp ctx.app_name ctx.mod_name ctx.hlp_name if (scan(current_object,CLN_DEL_TYPE)) begin if (live and wr_del) close_output send restart procedure_return end end find gt ctx by recnum [found] loop end if (select_state(opt, 2)) begin send start_process to (process(current_object)) "Groups" if (live and wr_del) direct_output (current_pth + current_grp + DEL_EXT_TEXT) clear grp find ge grp by recnum [found] repeat if (scan(current_object,CLN_SCAN_TYPE)) begin if (live and wr_del) close_output send restart procedure_return end clear xrf move grp.recnum to xrf.grp_recnum find ge xrf.grp_recnum [found] indicate found as xrf.grp_recnum eq grp.recnum [not found] begin if live begin if wr_del send write_del_grp move grp.recnum to rec indicate err false reread grp [not err] delete grp unlock clear grp move rec to grp.recnum end else send show_del_grp to disp grp.grp_name if (scan(current_object,CLN_DEL_TYPE)) begin if (live and wr_del) close_output send restart procedure_return end end find gt grp by recnum [found] loop end if (select_state(opt, 3)) begin send start_process to (process(current_object)) "Subjects" if (live and wr_del) direct_output (current_pth + current_sbj + DEL_EXT_TEXT) clear sbj find ge sbj by recnum [found] repeat if (scan(current_object,CLN_SCAN_TYPE)) begin if (live and wr_del) close_output send restart procedure_return end clear xrf move sbj.recnum to xrf.sbj_recnum find ge xrf.sbj_recnum [found] indicate found as xrf.sbj_recnum eq sbj.recnum [not found] begin if live begin if wr_del send write_del_sbj move sbj.recnum to rec indicate err false reread sbj [not err] delete sbj unlock clear sbj move rec to sbj.recnum end else send show_del_sbj to disp sbj.sbj_name if (scan(current_object,CLN_DEL_TYPE)) begin if (live and wr_del) close_output send restart procedure_return end end find gt sbj by recnum [found] loop end if (live and wr_del) close_output send process_complete live end_procedure procedure write_del_grp writeln grp.recnum writeln grp.grp_name end_procedure procedure write_del_sbj writeln sbj.recnum writeln sbj.sbj_name close_output send read_dbms to (sbj_text(current_object)) sbj.sbj_text send write to (sbj_text(current_object)) ; (current_pth + current_ctx + DEL_EXT_TEXT) true // true=append append_output (current_pth + current_ctx + DEL_EXT_TEXT) writeln (character(255)) end_procedure procedure write_del_xrf writeln xrf.recnum writeln xrf.grp_recnum writeln xrf.sbj_recnum end_procedure procedure write_del_ctx writeln ctx.recnum writeln ctx.app_name writeln ctx.mod_name writeln ctx.hlp_name writeln ctx.xrf_recnum end_procedure function scan integer itm returns integer function_return (scan(process(current_object),itm)) end_function procedure request_cancel send deactivate_area send insert_cb SUCCESS_REPLY 0 end_procedure end_object // cleanup send popup to cleanup end if cmd_option eq REORD_MAINT_OPTION begin /reorder_img ╔═════════════════════════════════════════════════════════════════════════╗ ║_________________________________________________________________________║ ║ ║ ║ This option will re-order all records in the Group and Subject ║ ║ files, adjusting the related Link records. ║ ║ ║ ║ _______ ________ ______ ║ ║ ║ ╚═════════════════════════════════════════════════════════════════════════╝ /* // <Begin> <Cancel> <Help> sub_page reorder_btns_img from reorder_img 2 3 4 object reorder is a client reorder_img set block_mouse_state to true set location to 6 3 relative set popup_state to true set scope_state to true set center_state item 0 to true set value item 0 to "Re-order Data" object buttons is a button reorder_btns_img item_list on_item "<Begin>" send request_begin on_item "<Cancel>" send request_cancel on_item "<Help>" send help end_item_list on_key kcancel send request_cancel end_object procedure request_begin send deactivate_area send reorder to reorder_process end_procedure procedure request_cancel send deactivate_area send insert_cb FAIL_REPLY 0 end_procedure end_object /reorder_process_img ╔═══════════════════════════════════════════════════╗ ║ ║ ║ Re-ordering ║ ║ ║ ║ ║ ║ ║ ║ ║ ║ ║ ╚═══════════════════════════════════════════════════╝ /reorder_process_display_img Groups: _____ Subjects: _____ /reorder_process_cancel_btn_img ____________ /* object reorder_process is a client reorder_process_img set popup_state to true set location to 7 14 relative object display is a message reorder_process_display_img set focus_mode to nonfocusable set location to 4 1 relative end_object object button is a button reorder_process_cancel_btn_img set location to 6 20 relative item_list on_item ESC_CANCEL_TEXT send none end_item_list /reorder_interrupt_img ╔═══════════════════════════════════════════════════════╗ ║ Re-ordering interrupted. ║ ║ ║ ║ _____________ ___________ ║ ╚═══════════════════════════════════════════════════════╝ /* object interrupt is a button reorder_interrupt_img set block_mouse_state to true set location to 0 -23 relative set popup_state to true set scope_state to true item_list on_item "<F2=Continue>" send ok on_item "<Esc=Abort>" send cancel end_item_list on_key ksave_record send ok on_key kcancel send cancel end_object function check_interrupt returns integer local string trash local integer wloc mloc ret_val inkey trash if (termchar eq kexit_application or ; termchar eq kcancel or ; termchar eq kmouse) begin if (termchar eq kmouse) begin get window_location item 1 to wloc move (wloc + location(current_object)) to wloc get absolute_mouse_location to mloc if not (mloc >= wloc and mloc < (wloc + length(value(current_object,0)))) ; function_return 0 end set kbd_input_mode to 1 set highlight_state to false ui_accept (interrupt(current_object)) to ret_val if ret_val ne msg_ok function_return 1 set highlight_state to true set kbd_input_mode to 2 end function_return 0 end_function end_object // button /reorder_done_img ╔═══════════════════════════════════════════════════════╗ ║ Re-ordering complete. ║ ║ ║ ║ ____ ______ ║ ╚═══════════════════════════════════════════════════════╝ /* object done is a button reorder_done_img set block_mouse_state to true set location to 5 -2 relative set popup_state to true set scope_state to true item_list on_item "<OK>" send request_ok on_item "<Help>" send help end_item_list procedure request_ok send deactivate_area delegate send deactivate_area end_procedure end_object object sbj_text_a is an edit set focus_mode to no_activate set size to 1 56 end_object object sbj_text_b is an edit set focus_mode to no_activate set size to 1 56 end_object function scan integer itm returns integer local integer ret_val obj move (display(current_object)) to obj set value of obj item itm to (value(obj,itm) + 1) get check_interrupt of (button(current_object)) to ret_val function_return ret_val end_function procedure reorder local integer ret_val send delete_data to (display(current_object)) send popup set highlight_state of (button(current_object)) to true set kbd_input_mode to 2 get reorder_grp to ret_val if not ret_val get reorder_sbj to ret_val set kbd_input_mode to 1 send insert_cb SUCCESS_REPLY 0 if not ret_val send popup to (done(current_object)) else send deactivate_area end_procedure function reorder_grp returns integer local integer rec_a rec_b ret_val clear grp find ge grp.recnum [found] begin move grp.recnum to rec_a clear grp find ge grp.grp_name [found] move grp.recnum to rec_b end [found] repeat if rec_b ne rec_a send swap_grp rec_a rec_b move rec_a to rec_b clear grp move rec_a to grp.recnum find gt grp.recnum [found] begin move grp.recnum to rec_a clear grp move rec_b to grp.recnum find eq grp.recnum [found] find gt grp.grp_name [found] move grp.recnum to rec_b end get scan 0 to ret_val if ret_val function_return ret_val [found] loop function_return 0 end_function procedure swap_grp integer rec_a integer rec_b local string temp_name_a temp_name_b move grp.grp_name to temp_name_b // assume rec_b is in the buffer reread grp delete grp // delete b clear grp move rec_a to grp.recnum find eq grp.recnum // refind a move grp.grp_name to temp_name_a // record data in a move temp_name_b to grp.grp_name // overwrite a data with b data saverecord grp // save b in a's place send adjust_grp grp.recnum -1 // de-assign current links for a send adjust_grp rec_b grp.recnum // assign old b links to new b clear grp move temp_name_a to grp.grp_name // re-create a (probably in b's place) saverecord grp send adjust_grp -1 grp.recnum // re-assign old a links to new a unlock end_procedure procedure adjust_grp integer old_rec integer new_rec repeat clear xrf move old_rec to xrf.grp_recnum find ge xrf.grp_recnum [found] indicate found as xrf.grp_recnum eq old_rec [found] begin reread xrf move new_rec to xrf.grp_recnum saverecord xrf unlock end [found] loop end_procedure function reorder_sbj returns integer local integer rec_a rec_b ret_val clear sbj find ge sbj.recnum [found] begin move sbj.recnum to rec_a clear sbj find ge sbj.sbj_name [found] move sbj.recnum to rec_b end [found] repeat if rec_b ne rec_a send swap_sbj rec_a rec_b move rec_a to rec_b clear sbj move rec_a to sbj.recnum find gt sbj.recnum [found] begin move sbj.recnum to rec_a clear sbj move rec_b to sbj.recnum find eq sbj.recnum [found] find gt sbj.sbj_name [found] move sbj.recnum to rec_b end get scan 1 to ret_val if ret_val function_return ret_val [found] loop function_return 0 end_function procedure swap_sbj integer rec_a integer rec_b local string temp_name_a temp_name_b move sbj.sbj_name to temp_name_b // assume rec_b is in the buffer send delete_data to (sbj_text_b(current_object)) send read_dbms to (sbj_text_b(current_object)) sbj.sbj_text reread sbj delete sbj // delete b clear sbj move rec_a to sbj.recnum find eq sbj.recnum // refind a move sbj.sbj_name to temp_name_a // record data in a send delete_data to (sbj_text_a(current_object)) send read_dbms to (sbj_text_a(current_object)) sbj.sbj_text move temp_name_b to sbj.sbj_name // overwrite a data with b data send write_dbms to (sbj_text_b(current_object)) sbj.sbj_text saverecord sbj // save b in a's place send adjust_sbj sbj.recnum -1 // de-assign current links for a send adjust_sbj rec_b sbj.recnum // assign old b links to new b clear sbj move temp_name_a to sbj.sbj_name // re-create a (probably in b's place) send write_dbms to (sbj_text_a(current_object)) sbj.sbj_text saverecord sbj send adjust_sbj -1 sbj.recnum // re-assign old a links to new a unlock end_procedure procedure adjust_sbj integer old_rec integer new_rec repeat clear xrf move old_rec to xrf.sbj_recnum find ge xrf.sbj_recnum [found] indicate found as xrf.sbj_recnum eq old_rec [found] begin reread xrf move new_rec to xrf.sbj_recnum saverecord xrf unlock end [found] loop end_procedure end_object send popup to reorder end on_key kexit_application send exit_program ////////////////////////////////// ////////////////////////////////// main logic ////////////////////////////////// start_ui if cmd_option ne REORD_MAINT_OPTION send insert_cb SUCCESS_REPLY 0 abort